Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/COMPNENT/ISAMEXPT/NUMCTRL.PAS

Pascal/Delphi Source File | 1996-04-04 | 18KB | 688 lines

unit NumCtrl;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Menus, DsgnIntF;

{ string edit component }
type
  TCustomStrEdit = class (TCustomEdit)
  private
    FAlignment: TAlignment;
    FOldAlignment : TAlignment;
    FTextMargin : integer;
    FRightNull  : Boolean;
    function CalcTextMargin : integer;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit);   message CM_EXIT;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure SetAlignment(Value: TAlignment);
  protected
    property Alignment: TAlignment read FAlignment write SetAlignment default taRightJustify;
    property RightNull: Boolean read FRightNull write FRightNull default False;
    procedure FormatText; dynamic;
    procedure UnFormatText; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TStrEdit = class (TCustomStrEdit)
  published
    property Alignment;
    property AutoSize;
    property BorderStyle;
    property CharCase; {KB}
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property HideSelection;
    property MaxLength;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property RightNull; {KB}
    property ShowHint;
    property TabOrder;
    property Visible;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

type
  TNumericType = (ntGeneral, ntCurrency, ntPercentage);
  TMaskString = string [25];

{ mask component }
type
  TMasks = class (TPersistent)
  private
    FPositiveMask : TMaskString;
    FNegativeMask : TMaskString;
    FZeroMask : TMaskString;
    FOnChange: TNotifyEvent;
  protected
    procedure SetPositiveMask (Value : TMaskString);
    procedure SetNegativeMask (Value : TMaskString);
    procedure SetZeroMask (Value : TMaskString);
  public
    constructor Create;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  published
    property PositiveMask : TMaskString read FPositiveMask write SetPositiveMask;
    property NegativeMask : TMaskString read FNegativeMask write SetNegativeMask;
    property ZeroMask : TMaskString read FZeroMask write SetZeroMask;
  end;

{ num edit component }
type
  TCustomNumEdit = class (TCustomStrEdit)
  private
    FDecimals : word;
    FDigits : word;
    FMasks : TMasks;
    FMax : extended;
    FMin : extended;
    FNumericType : TNumericType;
    FUseRounding : boolean;
    FValue : extended;
    FValidate : boolean;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit);   message CM_EXIT;
    procedure SetDecimals(Value : word);
    procedure SetDigits(Value : word);
    procedure SetMasks (Mask : TMasks);
    procedure SetMax(Value : extended);
    procedure SetMin(Value : extended);
    procedure SetNumericType(Value : TNumericType);
    procedure SetValue(Value : extended);
    procedure SetValidate(Value : boolean);
  protected
    procedure FormatText; dynamic;
    procedure KeyPress(var Key: Char); override;
    procedure UnFormatText; dynamic;
    property Decimals : word read FDecimals write SetDecimals;
    property Digits : word read FDigits write SetDigits;
    property Masks : TMasks read FMasks write SetMasks;
    property Max : extended read FMax write SetMax;
    property Min : extended read FMin write SetMin;
    property NumericType : TNumericType read FNumericType write SetNumericType default ntCurrency;
    property UseRounding : boolean read FUseRounding write FUseRounding;
    property Value : extended read FValue write SetValue;
    property Validate : boolean read FValidate write SetValidate;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function AsDouble : double; dynamic;
    function AsInteger : integer; dynamic;
    function AsLongint : longint; dynamic;
    function AsReal : real; dynamic;
    function AsString : string; dynamic;
    procedure MaskChanged ( Sender : TObject );
    function Valid ( Value : extended ) : boolean; dynamic;
  end;

  TNumEdit = class (TCustomNumEdit)
  published
    property AutoSize;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property Decimals;
    property Digits;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property HideSelection;
    property Masks;
    property Max;
    property Min;
    property NumericType;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property UseRounding;
    property Value;
    property Validate;
    property Visible;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

implementation

type
  TSetOfChar = set of char;
var
  OldMaxLength : integer;

{========================================================================}
{ support routines                                                       }
{========================================================================}

function Power ( X, Y : integer ) : real;
begin
  Result := exp ( ln ( X ) * Y );
end;

function StripChars ( const Text : string; ValidChars : TSetOfChar ) : string;
var
  S : string;
  i : integer;
  Negative : boolean;
Begin
  Negative := false;
  if (Text [ 1 ] = '-') or (Text [length (Text)] = '-' ) then
    Negative := true;
  S := '';
  for i := 1 to length ( Text ) do
    if Text [ i ] in ValidChars then
      S := S + Text [ i ];
  if Negative then
    Result := '-' + S
  else
    Result := S;
End;

{========================================================================}
{ Custom String Edit                                                     }
{========================================================================}

constructor TCustomStrEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAlignment := taLeftJustify;
  FTextMargin := CalcTextMargin;
end;

function TCustomStrEdit.CalcTextMargin : integer;
{borrowed from TDBEdit}
{calculates a pixel offset from the edge of the control to the text(a margin)}
{used in the paint routine}
var
  DC: HDC;
  SaveFont: HFont;
  I: Integer;
  SysMetrics, Metrics: TTextMetric;
begin
  DC := GetDC(0);
  GetTextMetrics(DC, SysMetrics);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  I := SysMetrics.tmHeight;
  if I > Metrics.tmHeight then
    I := Metrics.tmHeight;
  Result := I div 4;
end;

procedure TCustomStrEdit.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
    begin
    FAlignment := Value;
    Invalidate;
    end;
end;

procedure TCustomStrEdit.CMEnter(var Message: TCMEnter);
begin
  if FRightNull then UnformatText;
  inherited;
  FOldAlignment := FAlignment;
  Alignment := taLeftJustify;
end;

procedure TCustomStrEdit.CMExit(var Message: TCMExit);
begin
  if FRightNull then FormatText;
  inherited;
  Alignment := FOldAlignment;
end;

Procedure TCustomStrEdit.UnformatText;
begin
  Text := StripChars ( Text, [ '0'..'9', DecimalSeparator, ThousandSeparator ] );
end;

procedure TCustomStrEdit.FormatText;
var Txt: String;
begin
  Txt:= Text;
  while Length(Txt) < MaxLength do Txt:= '0'+Txt;
  Text:= Txt;
end;

procedure TCustomStrEdit.WMPaint(var Message: TWMPaint);
{borrowed from TDBEdit}
{paints the text in the appropriate position}
var
  Width, Indent, Left, I: Integer;
  R: TRect;
  DC: HDC;
  PS: TPaintStruct;
  S: string;
  Canvas: TControlCanvas;
begin
  {let the existing code handle left justify}
  if (FAlignment = taLeftJustify) then
    begin
    inherited;
    Exit;
    end;

  try
    Canvas := TControlCanvas.Create;
    Canvas.Control := Self;
    DC := Message.DC;
    if DC = 0 then
      DC := BeginPaint(Handle, PS);
    Canvas.Handle := DC;

    Canvas.Font := Font;
    with Canvas do
      begin
      R := ClientRect;
      if (BorderStyle = bsSingle) then
        begin
        Brush.Color := clWindowFrame;
        FrameRect(R);
        InflateRect(R, -1, -1);
        end;
      Brush.Color := Color;
      S := Text;
      Width := TextWidth(S);
      if BorderStyle = bsNone then
        Indent := 0
      else
        Indent := FTextMargin;
      if FAlignment = taRightJustify then
        Left := R.Right - Width - Indent
      else
        Left := (R.Left + R.Right - Width) div 2;
      TextRect(R, Left, Indent, S);
      end;
  finally
    Canvas.Handle := 0;
    if Message.DC = 0 then
      EndPaint(Handle, PS);
  end;{try}
end;
{========================================================================}
{ Masks object                                                           }
{========================================================================}

constructor TMasks.Create;
begin
  inherited Create;
  FPositiveMask := '#.##0';
  FNegativeMask := '';
  FZeroMask := '';
end;

procedure TMasks.SetPositiveMask (Value : TMaskString);
begin
  if FPositiveMask <> Value then
    begin
    FPositiveMask := Value;
    OnChange(Self);
    end;
end;

procedure TMasks.SetNegativeMask (Value : TMaskString);
begin
  if FNegativeMask <> Value then
    begin
    FNegativeMask := Value;
    OnChange(Self);
    end;
end;

procedure TMasks.SetZeroMask (Value : TMaskString);
begin
  if FZeroMask <> Value then
    begin
    FZeroMask := Value;
    OnChange(Self);
    end;
end;

{========================================================================}
{ Custom Numeric Edit                                                    }
{========================================================================}

constructor TCustomNumEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 85;
  FAlignment := taRightJustify;
  FNumericType := ntCurrency;
  FDigits := 12;
  FDecimals := 2;
  AutoSelect := true;
  FMax := 0.0;
  FMin := 0.0;
  FValidate := false;
  FValue := 0.0;
  FormatText;
  FTextMargin := CalcTextMargin;
  FUseRounding := true;
  FMasks := TMasks.Create;
  FMasks.OnChange := MaskChanged;
  DecimalSeparator := '.';
  ThousandSeparator := ',';
end;

destructor TCustomNumEdit.Destroy;
begin
  FMasks.Free;
  inherited Destroy;
end;

function TCustomNumEdit.AsInteger : integer;
const
  MaxInteger : integer = 32767;
  MinInteger : integer = -32768;
begin
  Result := 0;
  if (FValue < MaxInteger) and  (FValue > MinInteger) then
    if FUseRounding then
      Result := round ( FValue )
    else
      Result := trunc ( FValue );
end;

function TCustomNumEdit.AsLongint : longint;
const
  MaxLongint : longint = 2147483647;
  MinLongint : longint = -2147483647;
begin
  Result := 0;
  if (FValue < MaxLongint ) and  (FValue > MinLongint) then
    if FUseRounding then
      Result := round ( FValue )
    else
      Result := trunc ( FValue );
end;

function TCustomNumEdit.AsReal : real;
const
  MaxReal : real = 1.7E38;
  MinReal : real = -1.7E38;
begin
  Result := 0;
  if (FValue < MaxReal) and  (FValue > MinReal) then
     Result := FValue;
end;

function TCustomNumEdit.AsDouble : double;
const
  MaxDouble : double = 1.7E308;
  MinDouble : double = -1.7E308;
begin
  Result := 0;
  if (FValue < MaxDouble) and  (FValue > MinDouble) then
     Result := round ( FValue );
end;

function TCustomNumEdit.AsString : string;
const
  ValidChars = [ '0'..'9', ',', '.' ];
begin
  Result := StripChars ( Text, ValidChars );
  if Value < 0 then
    Result := '-' + Result;
end;

procedure TCustomNumEdit.SetMasks (Mask : TMasks);
begin
  if fMasks <> Mask then
    begin
    fMasks := Masks;
    Invalidate;
    end;
end;

procedure TCustomNumEdit.SetMin(Value : extended);
begin
  if FMin <> Value then
    begin
    FMin := Value;
    if FValue < FMin then
      FValue := FMin;
    end;
end;

procedure TCustomNumEdit.SetMax(Value : extended);
begin
  if FMax <> Value then
    begin
    FMax := Value;
    if FValue > FMax then
      FValue := FMax;
    end;
end;

procedure TCustomNumEdit.SetValue(Value : extended);
begin
  if ( FValue <> Value ) and ( Valid ( Value ) ) then
    begin
    FValue := Value;
    FormatText;
    end;
end;

procedure TCustomNumEdit.SetDigits(Value : word);
begin
  if FDigits <> Value then
    begin
    FDigits := Value;
    FormatText;
    end;
end;

procedure TCustomNumEdit.SetDecimals (Value : word);
var NStr: TMaskString;
    i   : Integer;
begin
  if FDecimals <> Value then begin
    FDecimals := Value;
    FormatText;
    if csDesigning in ComponentState then begin
      NStr:= '';
      i:= 0;
      if FDecimals > Digits then Digits:= Decimals + 1;
      While i < Digits - Decimals - 1 do begin
        NStr:= NStr + '#';
        Inc(i);
      end;
      NStr:= NStr + '0';
      if (Decimals > 0) then begin
        NStr:= NStr + '.';
        i:= 0;
        While i < Decimals - 1 do begin
          NStr:= NStr + '#';
          inc(i);
        end;
        NStr:= NStr + '0';
      end;
      Masks.PositiveMask:= NStr;
    end;
  end;
end;

procedure TCustomNumEdit.SetNumericType(Value: TNumericType);
begin
  if FNumericType <> Value then
    begin
    FNumericType := Value;
    FormatText;
    end;
end;

procedure TCustomNumEdit.SetValidate(Value : boolean);
begin
  if FValidate <> Value then
    begin
    FValidate:= Value;
    if FValidate and (( FValue < FMin ) or ( FValue > FMax )) then
      begin
      FValue := FMin;
      FormatText;
      end;
    end;
end;

function TCustomNumEdit.Valid ( Value : extended ) : boolean;
var
  S : string [80];
begin
  Result := true;
  if Validate and (( Value < FMin ) or ( Value > FMax )) then
    begin
    FmtStr( S, 'Der eingegebene Wert mu▀ zwischen %g und %g liegen', [FMin, FMax]);
    MessageDlg(S,mtError, [mbOk], 0);
    Result := false;
    end;
end;

procedure TCustomNumEdit.KeyPress(var Key: Char);
begin
  {only allow numerics, commas and one period}
  if (Key = DecimalSeparator) and (pos (DecimalSeparator, Text) = 0) then
    begin
    inherited KeyPress(Key);
    MaxLength := MaxLength + 1;
    end
  else
  if ( Key = '-' ) and ( pos ( '-', Text ) = 0 ) then
    begin
    inherited KeyPress(Key);
    MaxLength := MaxLength + 1;
    end
  else
  if Key in [ '0'..'9', ThousandSeparator, #8 ] then
    inherited KeyPress(Key)
  else
    Key := #0;
end;

procedure TCustomNumEdit.CMEnter(var Message: TCMEnter);
begin
  {strip the mask and left justify the field}
  UnFormatText;
  OldMaxLength := MaxLength;
  MaxLength := FDigits;
  inherited;
end;

procedure TCustomNumEdit.CMExit(var Message: TCMExit);
var
  S : string [80];
  X : extended;
begin
  {format the string with the mask when leaving the field}
  MaxLength := OldMaxLength;
  S := StripChars (Text, [ '0'..'9', DecimalSeparator ]); {remove all literal characters}
  if S = '' then
    X := 0.0
  else
    X := StrToFloat ( S );
  if Valid ( X ) then
    begin
    if FNumericType = ntPercentage then
      FValue := X / 100
    else
      FValue := X;
    FormatText;
    inherited;
    end
  else
    begin
    SelectAll;
    SetFocus;
    end;
end;

procedure TCustomNumEdit.FormatText;
var
  X : extended;
  Multiplier : real;
begin
  {round the number appropriately}
  try
    Multiplier := Power ( 10, Decimals );
    if FNumericType = ntPercentage then
      X := FValue * 100
    else
      X := FValue;
    if UseRounding then
      X := round ( X * Multiplier ) / Multiplier
    else
      X := trunc ( X * Multiplier ) / Multiplier;
  except
    on ERangeError do
      X := FValue; {will cause rounding in the FloatToStr function}
  end;

  {format the number}
  case FNumericType of
    ntCurrency   : Text := FloatToStrF ( X, ffCurrency, FDigits, FDecimals);
    ntPercentage : Text := FloatToStrF ( X, ffFixed, FDigits, FDecimals) + '%';
    ntGeneral    : with Masks do
                     Text := FormatFloat( PositiveMask+';'+NegativeMask+';'+ZeroMask, X);
  end;
end;

procedure TCustomNumEdit.MaskChanged ( Sender : TObject );
begin
  FormatText;
end;

procedure TCustomNumEdit.UnFormatText;
Begin
  Text := StripChars ( Text, [ '0'..'9', DecimalSeparator, ThousandSeparator ] );
  if Value < 0 then
    Text := '-' + Text;
End;

End.